home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / zBase < prev    next >
Text File  |  1998-06-08  |  10KB  |  423 lines
  1. ¥ zBase
  2.  
  3. ¥ This file is the PPC equivalent of the 68k "Base" file.  It's a
  4. ¥ "z" file - it's not target compiled, but is loaded on the PPC itself.
  5. ¥ Some PPC defns have already been target compiled in pBase - here we
  6. ¥ include all the rest.
  7.  
  8. ¥ [ and ] have been left to here as problems arise if we try to define
  9. ¥  them in the target compilation.
  10.  
  11.  
  12. ¥        ================= MARKER-related words ==================
  13. ¥
  14. ¥ Before we do anything else, we need to resolve some forward definitions
  15. ¥  required by MARKER.  MARKER is in pBase since we need it to be already
  16. ¥  defined before we load this file, so that it gets a proper file mark.
  17.  
  18.  
  19. 0    value    cdp2use
  20.  
  21. : (mrk)
  22.     cdp2use
  23.     dup displace    -> CDP  4 +
  24.         displace    -> DP
  25.     CDP (forget)
  26.     -echo
  27. ;
  28.  
  29. :f marker_h  ( xt -- )
  30.     2 + -> cdp2use
  31.     ['] (mrk)  (comp)
  32. ;f
  33.  
  34. :f fmrk  ( addr -- )
  35.     -> cdp2use  (mrk)  ;f
  36.  
  37.  
  38. ¥        ==================================================
  39.  
  40. false    value    testing?
  41. false    value    torture?
  42.  
  43. : xx  db  ;
  44.  
  45. : [        (suspend_compilation)  0 -> state  ;        immediate
  46. : ]        (resume_compilation)  -1 -> state  ;        immediate
  47.  
  48.  
  49. ¥ Some inline defns:
  50.  
  51. : 1+    inline{ 1 +} ;
  52. : 2+    inline{ 2 +} ;
  53. : 3+    inline{ 3 +} ;
  54. : 4+    inline{ 4 +} ;
  55.  
  56. : 1-    inline{ 1 -} ;
  57. : 2-    inline{ 2 -} ;
  58. : 3-    inline{ 3 -} ;
  59. : 4-    inline{ 4 -} ;
  60.  
  61. : 2*    inline{ 1 <<}  ;
  62. : 2/    inline{ 1 a>>} ;
  63. : 4*    inline{ 2 <<}  ;
  64. : 4/    inline{ 2 a>>} ;
  65.  
  66. ¥ ANSI words
  67.  
  68. : CELL+        inline{ 4 +} ;
  69. : CELL-        inline{ 4 -} ;
  70. : CELLS        inline{ 2 <<} ;
  71. : CHAR+        inline{ 1 +} ;
  72. : CHARS        inline{ } ;
  73.  
  74. 4    constant    1CELL            ¥ Not ANSI, but useful
  75.  
  76.  
  77. ¥ (") is in qpCond.
  78.  
  79.  
  80. ¥    In the 68k version, :a ... ;a is used for action handlers, to set up the
  81. ¥    module base register if we're calling a word in a module.  On the PPC, our
  82. ¥    reloc addr format identifies the segment, so we can take care of everything
  83. ¥    in our x-addr and x-array classes.  So here we just define :a and ;a to be
  84. ¥    the same as : and ;.
  85.  
  86.  
  87. : :A    postpone :  ;            immediate
  88. : ;A    postpone ;  ;            immediate
  89.  
  90.  
  91. : "
  92.     state
  93.     IF        (")                        ¥ compiling
  94.     ELSE    34 parse                ¥ interpreting
  95.     THEN
  96. ;                immediate
  97.  
  98.  
  99. : S"    postpone "  ;        immediate        ¥ ANSI synonym for "
  100.  
  101.  
  102. : ."
  103.     state
  104.     IF        (")  postpone type        ¥ compiling
  105.     ELSE    34 parse  type            ¥ interpreting
  106.     THEN
  107. ;                    immediate
  108.  
  109. : ABORT"
  110.     postpone "
  111.     postpone do_abq  ;        immediate
  112.  
  113.  
  114. ¥ (* ... *) defines a multi-line comment, which can be very useful.  Many
  115. ¥ Pascal compilers use these symbols - I thought it better not to use
  116. ¥ the C-style /* ... */  since */ already has a meaning.
  117. ¥ A useful improvement to the typical Pascal implementation is to keep a
  118. ¥ level count so that this kind of comment can be nested.
  119.  
  120. : (*
  121.     1                            ¥ initial level count
  122.     BEGIN
  123.         Mword  count  2dup
  124.         " (*"  s=
  125.         IF    2drop  1 +            ¥ increment level count
  126.         ELSE
  127.             " *)"  s=
  128.             IF  1 -                ¥ decrement level count
  129.                 ?dup  0EXIT        ¥ and if zero, we're done
  130.             THEN
  131.         THEN
  132.     AGAIN  ;        immediate
  133.  
  134.  
  135. variable NULLOSSTR
  136. 0  nullOSstr !
  137.  
  138.  
  139. : @WORD        ¥ ( -- addr )  Gets next blank-delimited word from input stream,
  140.             ¥  with no case conversion.
  141.     bl word  ;
  142.  
  143. : LIT        ¥ ( n -- )  A state-smart version of LITERAL.  Corresponds
  144.             ¥ to LITERAL in Fig-Forth or original Neon, whereas our
  145.             ¥ present LITERAL is ANSI.
  146.  
  147.     state  IF  postpone literal  THEN  ;        immediate
  148.  
  149. : 0,  0 ,  ;        ¥ Compiles an empty cell
  150.  
  151. : @VAL    intrp1  ;    ¥ Compiles a number from input stream
  152.  
  153.  
  154. : 'TYPE        ¥ ( -- 4bytes )   OS type literal
  155.     pad 4 bl fill  @word count 4 min
  156.     pad swap cmove  pad @  postpone lit  ;        immediate
  157.  
  158.  
  159. (*    RECURSE calls the current definition.  We need all the flag bytes
  160.     in place, so the regs get set up properly.  The second flag byte
  161.     is OK already, but we still need to set the first one, with the
  162.     #cells in regs on return.  So we now decide this if we
  163.     haven't already, put the flag byte there, then compile the call.
  164.     Note that recursive words must be non-leaf, since the LR has to be
  165.     saved.  This is looked after by (comp), and in any case the leaf
  166.     bit is the top bit in the flag byte we have to store, and we leave
  167.     it zero.
  168. *)
  169.  
  170. : RECURSE
  171.     get_rtn_cnts drop
  172.     curr-def 2-  c!
  173.     curr-def 2-  (comp)
  174. ;            immediate
  175.  
  176.  
  177. : CHAR        @word 1+ c@  ;
  178. : [CHAR]    @word 1+ c@  postpone literal  ;    immediate
  179.  
  180. : &            ¥ ( -- c )  A shorter state-smart version.
  181.     @word 1+ c@
  182.     postpone lit  ;            immediate
  183.  
  184.  
  185. : $            ¥ State-smart HEX literal word
  186.     base >r
  187.     hex  Mword  number  postpone lit
  188.     r> -> base  ;            immediate
  189.  
  190. ¥ Str255 stuff already defined, in setup and pBase.
  191.  
  192. ¥ Resource support is in pBase.
  193.  
  194. ¥ ================= Messages and errors ==================
  195.  
  196. : ?ERROR        ¥ ( b -- )  Aborts and prints resource string if true.
  197.                 ¥ Usage:  ?error 999
  198.     postpone if
  199.     intrp1  ( get err# )  postpone literal  postpone die
  200.     postpone then  ;        immediate
  201.  
  202.  
  203. ¥ this is now in pBase:
  204. ¥ : (TSTR)            ¥ ( id# -- )  Prints string with given resID.
  205. ¥    getString type  ;
  206.  
  207. : TYPE#        ¥ Prints string for id# in stream
  208.     intrp1  postpone lit   postpone tStr  ;        immediate
  209.  
  210.  
  211. : .RSTR    ¥ ( -- )  print "Msg# ..." then string with given resID
  212.     ." Msg# " dup . ." : "  tStr  ;
  213.  
  214. : MSG#        ¥  usage: " Msg# <number>"
  215.     intrp1  postpone lit  postpone .rStr  ;        immediate
  216.  
  217.  
  218. ¥ ====================================
  219.  
  220. : RDEPTH        rp0  rp@ - 4/ 2-  ;
  221.  
  222. : ?RDEPTH        rp@  sp0 20 + < ?error 116  ;    ¥ err if rtn stk about to
  223.                                                 ¥ collide with data stk
  224.  
  225. ¥        ========== Type checking ===========
  226.  
  227. ¥ Sometimes we want to check that a non-object parameter to a word is of a 
  228. ¥ certain type.  We give it a unique type code and use TYPCHK.
  229.  
  230. : TYPCHK    <>  ?error 179  ;
  231.  
  232.  
  233. ¥        ====================================
  234.  
  235.  
  236. ¥ Commonly needed error words.  These are forward defined - the main
  237. ¥ application should provide a sensible definition, with a nice friendly
  238. ¥ alert box, to tell the user in a nice friendly way that things are up
  239. ¥ the creek.
  240.  
  241. forward    NOMEM        ¥ Call when (not if!) we run out of memory.
  242.  
  243. forward    I/O_ERR        ¥ ( err# -- )  Call when there's an I/O error.
  244.  
  245. : OK?        ¥ ( rc -- )  A useful word to use after an I/O op.
  246.     ?dup  0EXIT  I/O_err  ;
  247.  
  248.  
  249.  
  250. ¥     ======== Various utility words needed later =========
  251.  
  252.  
  253. ¥ BECOME allows restarting at a given word, with all stacks
  254. ¥ empty.  This is necessary in menu handlers and other areas
  255. ¥ that could create indefinite nesting situations.
  256.  
  257. ' quit    vect    becomeXT
  258.  
  259. : BE    sp0 sp!  rp0 rp!  becomeXT  quit  ;
  260.  
  261. : (BE)    -> becomeXT be  ;
  262.  
  263.  
  264. : BECOME        ¥ Usage: Become newWord - compiles code to Be at runtime
  265.     state
  266.     IF        postpone [']  postpone (be)
  267.     ELSE    '  -> becomeXT  be
  268.     THEN  ;            immediate
  269.  
  270.  
  271. : DATETIME
  272.     $ 20C  @  ;
  273.  
  274.  
  275. ¥        ============ Tables, lists etc. ===============
  276.  
  277. (*    From Mops 2.5 on, we're trying to be consistent with the way we delimit
  278.     various kinds of lists with { ... }.  No, we're not trying to copy C,
  279.     but let's at least follow the "principle of minimum astonishment".
  280.     Thus, with words like xts{, we'll allow a variant "xts {" where you
  281.     can put a space before the "{".  This is very easy to implement, so
  282.     why not?
  283. *)
  284.  
  285. forward  {        immediate
  286.  
  287. : GOBBLE{        ¥ gobbles a "{" which must follow as a separate word.
  288.     '  ['] {  <>  ?error 113  ;        ¥ "{" expected
  289.  
  290. : )        123 die  ;    immediate        ¥ ") read when no list is current"
  291. : (})    123 die  ;    immediate        ¥ "unmatched }"
  292.  
  293. ' (})    vect    }                    ¥ } will mean different things in different
  294.                                     ¥  contexts.
  295.  
  296. : }OR)?        ¥ ( cfa -- cfa b )
  297.     dup  ['] }  =  over  ['] ) =  or  ;
  298.  
  299.  
  300. : XTS{            ¥ State-smart word to compile or stack a list
  301.                 ¥ of xts.  Pulls words from stream, until "}".
  302.     0
  303.     BEGIN   '   }or)?
  304.     NWHILE    state    IF        ¥ const_data_ref  reloc>const_data  postpone @abs
  305.                             lit_addr
  306.                     ELSE    swap 
  307.                     THEN  1+
  308.     REPEAT
  309.     drop   state IF  postpone literal  THEN  ;        immediate
  310.  
  311. : CFAS{    postpone xts{  ;    immediate        ¥ Synonyms for compatibility
  312. : CFAS(    postpone xts{  ;    immediate
  313.  
  314. : XTS    gobble{  postpone xts{  ;        immediate
  315.  
  316.  
  317. (* SCON defines a string constant.  Usage:
  318.  
  319.     scon    <name>    "a string"
  320.  
  321.   Runtime: ( -- addr len )
  322.  
  323.   Change from Neon: the first nonblank char after the name of the SCON
  324.   becomes the delimiter.  So " can be used as usual, but anything else can
  325.   be used instead, e.g.:
  326.  
  327.      scon    <name>    /this string contains " as non-delimiter/
  328. *)
  329.  
  330. : SCON
  331.     <BUILDS        bl skip-src+
  332.                 src-start >in @ + c@  ,dlm-str
  333.     DOES>        count  ;
  334.  
  335.  
  336. ¥ note: INSTEAD is defined in zArgs since it needs locals.
  337.  
  338.  
  339. ¥ CASE should be used for non-contiguous or dynamically computed values.
  340. ¥ This is a modified Eaker/Duncan model.
  341. ¥ Our optimization strategy gives quite good code.
  342.  
  343. : CASE        ?comp  302  ;        immediate
  344.  
  345. : OF
  346.     postpone over  postpone =  postpone if
  347.     postpone drop  ;            immediate
  348.  
  349. : RANGEOF
  350.     postpone within?  postpone if
  351.     postpone drop  ;            immediate
  352.  
  353. : ENDOF
  354.     postpone else  ;            immediate
  355.  
  356. : ENDCASE
  357.     postpone drop
  358.     BEGIN  dup 302 =  NWHILE  >resolve&equalize   REPEAT  drop  ;
  359. immediate
  360.  
  361. (* TYPE{ and ENUM{ (synonyms) define a Pascal/C-like enumerated type.
  362.    At this stage we don't give a name to the "type" as such, as we can't
  363.    do anything really sensible with it.  However later we can optionally
  364.    load the ENUM-TYPE class which is rather more Pascal-like.  But even
  365.    without that, the enumeration is very useful by itself.
  366. *)
  367.  
  368.     0    value    TYPECNT
  369.  
  370. ' null    vect    DO_ET        ¥ Hook for handling the ENUM-TYPE
  371.                             ¥ class when it's loaded
  372.  
  373. : ENDLIST?        ¥ ( chr -- b )
  374.     #lines_read >r
  375.     >in @  >r
  376.     Mword  count 1 =  down c@ =  and
  377.     IF        r> drop    r> drop  true        ¥ finished - leave delimiter skipped
  378.     ELSE    r>  >in !                    ¥ another list item - reread it
  379.             r> #lines_read <>
  380.             IF  0 >in !  THEN
  381.             false            
  382.     THEN  ;
  383.  
  384.  
  385. : ENUM{
  386.     0 -> typeCnt                ¥ 1st value
  387.     BEGIN    typeCnt  constant  1 ++> typeCnt
  388.             & }  endlist?
  389.     UNTIL
  390.     do_ET  ;
  391.  
  392. : TYPE{        enum{  ;            ¥ C fans might like this name better
  393.  
  394. : ENUM        gobble{  enum{  ;
  395.  
  396.                 ¥ note we can't allow "type { ..." since "type" has another
  397.                 ¥ meaning already.  But "enum { ..."  is OK.
  398.  
  399. enum{ InMainDic DataInMainDic InOtherMod DataInOtherMod InThisMod }
  400.                             ¥ Relocatable addr types
  401.  
  402.  
  403. ¥        ========== Error diagnostics ===========
  404.  
  405. ¥ We use special values for nil handles and nil pointers.  These are
  406. ¥ odd high addresses, so hopefully we'll trap if we try to use them.
  407.  
  408. : .RTN            ¥ ( addr -- )
  409.     cr ." From  $"
  410.     .h  4 spaces
  411. ;
  412.  
  413.  
  414. : RANGE_ERR        ¥ ( index range rtn-addr -- )
  415.     dup 1+ 0=  ?error 128            ¥ Spurious range error
  416.     .rtn
  417.     dup -1 <
  418.     IF        nip  ?error 130            ¥ Not an indexed class
  419.     ELSE    ." Range: " .  ."   Index: " .
  420.             true  ?error 129
  421.     THEN  ;
  422.  
  423.